home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-9.10-netbook-remix-PL.iso / casper / filesystem.squashfs / usr / share / perl5 / HTTP / Config.pm next >
Text File  |  2008-10-20  |  11KB  |  437 lines
  1. package HTTP::Config;
  2.  
  3. use strict;
  4. use URI;
  5. use vars qw($VERSION);
  6.  
  7. $VERSION = "5.815";
  8.  
  9. sub new {
  10.     my $class = shift;
  11.     return bless [], $class;
  12. }
  13.  
  14. sub entries {
  15.     my $self = shift;
  16.     @$self;
  17. }
  18.  
  19. sub empty {
  20.     my $self = shift;
  21.     not @$self;
  22. }
  23.  
  24. sub add {
  25.     if (@_ == 2) {
  26.         my $self = shift;
  27.         push(@$self, shift);
  28.         return;
  29.     }
  30.     my($self, %spec) = @_;
  31.     push(@$self, \%spec);
  32.     return;
  33. }
  34.  
  35. sub find2 {
  36.     my($self, %spec) = @_;
  37.     my @found;
  38.     my @rest;
  39.  ITEM:
  40.     for my $item (@$self) {
  41.         for my $k (keys %spec) {
  42.             if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
  43.                 push(@rest, $item);
  44.                 next ITEM;
  45.             }
  46.         }
  47.         push(@found, $item);
  48.     }
  49.     return \@found unless wantarray;
  50.     return \@found, \@rest;
  51. }
  52.  
  53. sub find {
  54.     my $self = shift;
  55.     my $f = $self->find2(@_);
  56.     return @$f if wantarray;
  57.     return $f->[0];
  58. }
  59.  
  60. sub remove {
  61.     my($self, %spec) = @_;
  62.     my($removed, $rest) = $self->find2(%spec);
  63.     @$self = @$rest if @$removed;
  64.     return @$removed;
  65. }
  66.  
  67. my %MATCH = (
  68.     m_scheme => sub {
  69.         my($v, $uri) = @_;
  70.         return $uri->_scheme eq $v;  # URI known to be canonical
  71.     },
  72.     m_secure => sub {
  73.         my($v, $uri) = @_;
  74.         my $secure = $uri->_scheme eq "https";
  75.         return $secure == !!$v;
  76.     },
  77.     m_host_port => sub {
  78.         my($v, $uri) = @_;
  79.         return unless $uri->can("host_port");
  80.         return $uri->host_port eq $v, 7;
  81.     },
  82.     m_host => sub {
  83.         my($v, $uri) = @_;
  84.         return unless $uri->can("host");
  85.         return $uri->host eq $v, 6;
  86.     },
  87.     m_port => sub {
  88.         my($v, $uri) = @_;
  89.         return unless $uri->can("port");
  90.         return $uri->port eq $v;
  91.     },
  92.     m_domain => sub {
  93.         my($v, $uri) = @_;
  94.         return unless $uri->can("host");
  95.         my $h = $uri->host;
  96.         $h = "$h.local" unless $h =~ /\./;
  97.         $v = ".$v" unless $v =~ /^\./;
  98.         return length($v), 5 if substr($h, -length($v)) eq $v;
  99.         return 0;
  100.     },
  101.     m_path => sub {
  102.         my($v, $uri) = @_;
  103.         return unless $uri->can("path");
  104.         return $uri->path eq $v, 4;
  105.     },
  106.     m_path_prefix => sub {
  107.         my($v, $uri) = @_;
  108.         return unless $uri->can("path");
  109.         my $path = $uri->path;
  110.         my $len = length($v);
  111.         return $len, 3 if $path eq $v;
  112.         return 0 if length($path) <= $len;
  113.         $v .= "/" unless $v =~ m,/\z,,;
  114.         return $len, 3 if substr($path, 0, length($v)) eq $v;
  115.         return 0;
  116.     },
  117.     m_path_match => sub {
  118.         my($v, $uri) = @_;
  119.         return unless $uri->can("path");
  120.         return $uri->path =~ $v;
  121.     },
  122.     m_uri__ => sub {
  123.         my($v, $k, $uri) = @_;
  124.         return unless $uri->can($k);
  125.         return 1 unless defined $v;
  126.         return $uri->$k eq $v;
  127.     },
  128.     m_method => sub {
  129.         my($v, $uri, $request) = @_;
  130.         return $request && $request->method eq $v;
  131.     },
  132.     m_proxy => sub {
  133.         my($v, $uri, $request) = @_;
  134.         return $request && ($request->{proxy} || "") eq $v;
  135.     },
  136.     m_code => sub {
  137.         my($v, $uri, $request, $response) = @_;
  138.         $v =~ s/xx\z//;
  139.         return unless $response;
  140.         return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
  141.     },
  142.     m_media_type => sub {  # for request too??
  143.         my($v, $uri, $request, $response) = @_;
  144.         return unless $response;
  145.         return 1, 1 if $v eq "*/*";
  146.         my $ct = $response->content_type;
  147.         return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
  148.         return 3, 1 if $v eq "html" && $response->content_is_html;
  149.         return 4, 1 if $v eq "html" && $response->content_is_xhtml;
  150.         return 10, 1 if $v eq $ct;
  151.         return 0;
  152.     },
  153.     m_header__ => sub {
  154.         my($v, $k, $uri, $request, $response) = @_;
  155.         return unless $request;
  156.         return 1 if $request->header($k) eq $v;
  157.         return 1 if $response && $response->header($k) eq $v;
  158.         return 0;
  159.     },
  160.     m_response_attr__ => sub {
  161.         my($v, $k, $uri, $request, $response) = @_;
  162.         return unless $response;
  163.         return 1 if !defined($v) && exists $response->{$k};
  164.         return 0 unless exists $response->{$k};
  165.         return 1 if $response->{$k} eq $v;
  166.         return 0;
  167.     },
  168. );
  169.  
  170. sub matching {
  171.     my $self = shift;
  172.     if (@_ == 1) {
  173.         if ($_[0]->can("request")) {
  174.             unshift(@_, $_[0]->request);
  175.             unshift(@_, undef) unless defined $_[0];
  176.         }
  177.         unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
  178.     }
  179.     my($uri, $request, $response) = @_;
  180.     $uri = URI->new($uri) unless ref($uri);
  181.  
  182.     my @m;
  183.  ITEM:
  184.     for my $item (@$self) {
  185.         my $order;
  186.         for my $ikey (keys %$item) {
  187.             my $mkey = $ikey;
  188.             my $k;
  189.             $k = $1 if $mkey =~ s/__(.*)/__/;
  190.             if (my $m = $MATCH{$mkey}) {
  191.                 #print "$ikey $mkey\n";
  192.                 my($c, $o);
  193.                 my @arg = (
  194.                     defined($k) ? $k : (),
  195.                     $uri, $request, $response
  196.                 );
  197.                 my $v = $item->{$ikey};
  198.                 $v = [$v] unless ref($v) eq "ARRAY";
  199.                 for (@$v) {
  200.                     ($c, $o) = $m->($_, @arg);
  201.                     #print "  - $_ ==> $c $o\n";
  202.                     last if $c;
  203.                 }
  204.                 next ITEM unless $c;
  205.                 $order->[$o || 0] += $c;
  206.             }
  207.         }
  208.         $order->[7] ||= 0;
  209.         $item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
  210.         push(@m, $item);
  211.     }
  212.     @m = sort { $b->{_order} cmp $a->{_order} } @m;
  213.     delete $_->{_order} for @m;
  214.     return @m if wantarray;
  215.     return $m[0];
  216. }
  217.  
  218. sub add_item {
  219.     my $self = shift;
  220.     my $item = shift;
  221.     return $self->add(item => $item, @_);
  222. }
  223.  
  224. sub remove_items {
  225.     my $self = shift;
  226.     return map $_->{item}, $self->remove(@_);
  227. }
  228.  
  229. sub matching_items {
  230.     my $self = shift;
  231.     return map $_->{item}, $self->matching(@_);
  232. }
  233.  
  234. 1;
  235.  
  236. __END__
  237.  
  238. =head1 NAME
  239.  
  240. HTTP::Config - Configuration for request and response objects
  241.  
  242. =head1 SYNOPSIS
  243.  
  244.  use HTTP::Config;
  245.  my $c = HTTP::Config->new;
  246.  $c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
  247.  
  248.  use HTTP::Request;
  249.  my $request = HTTP::Request->new(GET => "http://www.example.com");
  250.  
  251.  if (my @m = $c->matching($request)) {
  252.     print "Yadayada\n" if $m[0]->{verbose};
  253.  }
  254.  
  255. =head1 DESCRIPTION
  256.  
  257. An C<HTTP::Config> object is a list of entries that
  258. can be matched against request or request/response pairs.  Its
  259. purpose is to hold configuration data that can be looked up given a
  260. request or response object.
  261.  
  262. Each configuration entry is a hash.  Some keys specify matching to
  263. occur against attributes of request/response objects.  Other keys can
  264. be used to hold user data.
  265.  
  266. The following methods are provided:
  267.  
  268. =over 4
  269.  
  270. =item $conf = HTTP::Config->new
  271.  
  272. Constructs a new empty C<HTTP::Config> object and returns it.
  273.  
  274. =item $conf->entries
  275.  
  276. Returns the list of entries in the configuration object.
  277. In scalar context returns the number of entries.
  278.  
  279. =item $conf->empty
  280.  
  281. Return true if there are no entries in the configuration object.
  282. This is just a shorthand for C<< not $conf->entries >>.
  283.  
  284. =item $conf->add( %matchspec, %other )
  285.  
  286. =item $conf->add( \%entry )
  287.  
  288. Adds a new entry to the configuration.
  289. You can either pass separate key/value pairs or a hash reference.
  290.  
  291. =item $conf->remove( %spec )
  292.  
  293. Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
  294. If %spec is empty this will match all entries; so it will empty the configuation object.
  295.  
  296. =item $conf->matching( $uri, $request, $response )
  297.  
  298. =item $conf->matching( $uri )
  299.  
  300. =item $conf->matching( $request )
  301.  
  302. =item $conf->matching( $response )
  303.  
  304. Returns the entries that match the given $uri, $request and $response triplet.
  305.  
  306. If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
  307. If called with a single $response object, then the request object is obtained by calling its 'request' method;
  308. and then the $uri is obtained as if a single $request was provided.
  309.  
  310. The entries are returned with the most specific matches first.
  311. In scalar context returns the most specific match or C<undef> in none match.
  312.  
  313. =item $conf->add_item( $item, %matchspec )
  314.  
  315. =item $conf->remove_items( %spec )
  316.  
  317. =item $conf->matching_items( $uri, $request, $response )
  318.  
  319. Wrappers that hides the entries themselves.
  320.  
  321. =back
  322.  
  323. =head2 Matching
  324.  
  325. The following keys on a configuration entry specify matching.  For all
  326. of these you can provide an array of values instead of a single value.
  327. The entry matches if at least one of the values in the array matches.
  328.  
  329. Entries that require match against a response object attribute will never match
  330. unless a response object was provided.
  331.  
  332. =over
  333.  
  334. =item m_scheme => $scheme
  335.  
  336. Matches if the URI uses the specified scheme; e.g. "http".
  337.  
  338. =item m_secure => $bool
  339.  
  340. If $bool is TRUE; matches if the URI uses a secure scheme.  If $bool
  341. is FALSE; matches if the URI does not use a secure scheme.  An example
  342. of a secure scheme is "https".
  343.  
  344. =item m_host_port => "$hostname:$port"
  345.  
  346. Matches if the URI's host_port method return the specified value.
  347.  
  348. =item m_host => $hostname
  349.  
  350. Matches if the URI's host method returns the specified value.
  351.  
  352. =item m_port => $port
  353.  
  354. Matches if the URI's port method returns the specified value.
  355.  
  356. =item m_domain => ".$domain"
  357.  
  358. Matches if the URI's host method return a value that within the given
  359. domain.  The hostname "www.example.com" will for instance match the
  360. domain ".com".
  361.  
  362. =item m_path => $path
  363.  
  364. Matches if the URI's path method returns the specified value.
  365.  
  366. =item m_path_prefix => $path
  367.  
  368. Matches if the URI's path is the specified path or has the specified
  369. path as prefix.
  370.  
  371. =item m_path_match => $Regexp
  372.  
  373. Matches if the regular expression matches the URI's path.  Eg. qr/\.html$/.
  374.  
  375. =item m_method => $method
  376.  
  377. Matches if the request method matches the specified value. Eg. "GET" or "POST".
  378.  
  379. =item m_code => $digit
  380.  
  381. =item m_code => $status_code
  382.  
  383. Matches if the response status code matches.  If a single digit is
  384. specified; matches for all response status codes beginning with that digit.
  385.  
  386. =item m_proxy => $url
  387.  
  388. Matches if the request is to be sent to the given Proxy server.
  389.  
  390. =item m_media_type => "*/*"
  391.  
  392. =item m_media_type => "text/*"
  393.  
  394. =item m_media_type => "html"
  395.  
  396. =item m_media_type => "xhtml"
  397.  
  398. =item m_media_type => "text/html"
  399.  
  400. Matches if the response media type matches.
  401.  
  402. With a value of "html" matches if $response->content_is_html returns TRUE.
  403. With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
  404.  
  405. =item m_uri__I<$method> => undef
  406.  
  407. Matches if the URI object provide the method
  408.  
  409. =item m_uri__I<$method> => $string
  410.  
  411. Matches if the URI's $method method returns the given value.
  412.  
  413. =item m_header__I<$field> => $string
  414.  
  415. Matches if either the request or the response have a header $field with the given value.
  416.  
  417. =item m_response_attr__I<$key> => undef
  418.  
  419. =item m_response_attr__I<$key> => $string
  420.  
  421. Matches if the response object has a that key; or the entry has the given value.
  422.  
  423. =back
  424.  
  425. =head1 SEE ALSO
  426.  
  427. L<URI>, L<HTTP::Request>, L<HTTP::Response>
  428.  
  429. =head1 COPYRIGHT
  430.  
  431. Copyright 2008, Gisle Aas
  432.  
  433. This library is free software; you can redistribute it and/or
  434. modify it under the same terms as Perl itself.
  435.  
  436. =cut
  437.